Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/RGBCOLOR.FRM

Text File | 1997-01-03 | 8KB | 288 lines

VERSION 4.00
Begin VB.Form RGBColorForm
   Caption         =   "RGBColor"
   ClientHeight    =   3030
   ClientLeft      =   2055
   ClientTop       =   1605
   ClientWidth     =   5010
   Height          =   3720
   Left            =   1995
   LinkTopic       =   "Form1"
   ScaleHeight     =   202
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   334
   Top             =   975
   Width           =   5130
   Begin VB.PictureBox DefaultPict
      AutoRedraw      =   -1  'True
      Height          =   1650
      Left            =   0
      ScaleHeight     =   106
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   106
      TabIndex        =   13
      Top             =   0
      Width           =   1650
   End
   Begin VB.HScrollBar BlueScroll
      Height          =   255
      LargeChange     =   16
      Left            =   900
      Max             =   255
      TabIndex        =   7
      Top             =   2760
      Width           =   4080
   End
   Begin VB.HScrollBar GreenScroll
      Height          =   255
      LargeChange     =   16
      Left            =   900
      Max             =   255
      TabIndex        =   6
      Top             =   2400
      Width           =   4080
   End
   Begin VB.PictureBox CustomPict
      AutoRedraw      =   -1  'True
      Height          =   1650
      Left            =   3360
      Picture         =   "RGBCOLOR.frx":0000
      ScaleHeight     =   106
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   106
      TabIndex        =   5
      Top             =   0
      Width           =   1650
   End
   Begin VB.HScrollBar RedScroll
      Height          =   255
      LargeChange     =   16
      Left            =   900
      Max             =   255
      TabIndex        =   4
      Top             =   2040
      Width           =   4080
   End
   Begin VB.PictureBox RainbowPict
      AutoRedraw      =   -1  'True
      Height          =   1650
      Left            =   1680
      Picture         =   "RGBCOLOR.frx":0446
      ScaleHeight     =   106
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   106
      TabIndex        =   0
      Top             =   0
      Width           =   1650
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "Rainbow Palette"
      Height          =   255
      Index           =   5
      Left            =   1680
      TabIndex        =   14
      Top             =   1680
      Width           =   1650
   End
   Begin VB.Label BlueLabel
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   480
      TabIndex        =   12
      Top             =   2760
      Width           =   375
   End
   Begin VB.Label GreenLabel
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   480
      TabIndex        =   11
      Top             =   2400
      Width           =   375
   End
   Begin VB.Label RedLabel
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   480
      TabIndex        =   10
      Top             =   2040
      Width           =   375
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "Customized Palette"
      Height          =   255
      Index           =   4
      Left            =   3360
      TabIndex        =   9
      Top             =   1680
      Width           =   1650
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "Default Palette"
      Height          =   255
      Index           =   3
      Left            =   0
      TabIndex        =   8
      Top             =   1680
      Width           =   1650
   End
   Begin VB.Label Label1
      Caption         =   "Blue"
      Height          =   255
      Index           =   2
      Left            =   0
      TabIndex        =   3
      Top             =   2760
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "Green"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   2
      Top             =   2400
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "Red"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   1
      Top             =   2040
      Width           =   495
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "RGBColorForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Dim CustomPalette As Integer
Dim wid As Single
Dim hgt As Single

' ***********************************************
' Resize CustomPict's palette so it has only one
' entry. We will use that entry to display the
' color selected by the scroll bars.
' ***********************************************
Sub ShrinkPalette()
    CustomPalette = CustomPict.Picture.hPal
    If ResizePalette(CustomPalette, 1) = 0 Then
        Beep
        MsgBox "Error resizing palette.", vbExclamation
    End If
End Sub


' ***********************************************
' Display the selected RGB value in both picture
' boxes.
' ***********************************************
Sub UpdateColors()
Dim r As Integer
Dim g As Integer
Dim b As Integer
Dim palentry As PALETTEENTRY
Dim status As Integer

    r = RedScroll.Value
    g = GreenScroll.Value
    b = BlueScroll.Value

    ' Update the numeric labels.
    RedLabel.Caption = Format$(r)
    GreenLabel.Caption = Format$(g)
    BlueLabel.Caption = Format$(b)

    ' Display the color in the default picture.
    DefaultPict.Line (0, 0)-Step(wid, hgt), RGB(r, g, b), BF

    ' Display the color in the rainbow picture.
    RainbowPict.Line (0, 0)-Step(wid, hgt), RGB(r, g, b), BF

    ' Put the new color in the custom palette.
    palentry.peRed = r
    palentry.peGreen = g
    palentry.peBlue = b
    If SetPaletteEntries(CustomPalette, 0, 1, palentry) = 0 Then
        Beep
        MsgBox "Error updating palette entry.", vbExclamation
    End If

    ' Make the change take effect.
    status = RealizePalette(CustomPict.hdc)

    ' Fill the custom palette picture.
    CustomPict.Line (0, 0)-Step(wid, hgt), RGB(r, g, b) + &H2000000, BF
End Sub

Private Sub BlueScroll_Change()
    UpdateColors
End Sub

Private Sub BlueScroll_Scroll()
    UpdateColors
End Sub


Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If

    ' Save the lower right corner of the picture
    ' boxes for easier drawing later.
    wid = DefaultPict.ScaleWidth - 1
    hgt = DefaultPict.ScaleHeight - 1

    ' Load the system palette.
    ShrinkPalette

    ' Display the initial color (black).
    UpdateColors
End Sub


Private Sub GreenScroll_Change()
    UpdateColors
End Sub

Private Sub GreenScroll_Scroll()
    UpdateColors
End Sub



Private Sub mnuFileExit_Click()
    Unload Me
End Sub



Private Sub RedScroll_Change()
    UpdateColors
End Sub


Private Sub RedScroll_Scroll()
    UpdateColors
End Sub